//=============================================================================
///	Minimal Lisp
/**

Special Form:
	quote
	set		(setq)
	if
	fn		(lambda)
	macro
	quasiquote

Function:
	cons
	car
	cdr
	consp
	scar	(rplaca)
	scdr	(rplacd)
	is		(eq)
	type	(type-of)
	coerce
	+
	-
	*
	/
	mod
	<
	>
	<=
	>=
	apply
	append
	read
	eval
	disp	(write)
	load
	quit
	uniq	(gensym)
	macroexpand-1
	macex	(macroexpand)
	global-variable-ref

	set-macro-character
	get-macro-character
	read-delimited-list

	backtrace
*/
//=============================================================================

#include "mlisp.h"
#include "sexp.h"
#include "ssym.h"
#include "senv.h"
#include "sstream.h"
#include "sutil.h"
#include "seval.h"
#include "s_read.h"
#include "sstring.h"
#include "smem.h"
#include <stdarg.h>

#ifndef	FALSE
#define	FALSE	(0)
#define	TRUE	(1)
#endif


SExp sstdin, sstdout, sstderr;

static const char ERR_ILLEGAL_CLOSE_PAREN[] = "illegal close paren";
static const char ERR_CANT_LOAD[] = "can't load: ~a";
static const char ERR_CANT_COERCE[] = "can't coerce ~a -> ~a";

#define	ABS(x)		((x) >= 0 ? (x) : -(x))
#define	SGN(x)		(((x) > 0) ? +1 : ((x) < 0) ? -1 : 0)

//=============================================================================
// special form

static SExp macroexpand_sub(SExp args, int non_expand_num, int interval) {
	int chg = FALSE;
	SExp p;
	int cnt;
	push_stack(nil);
	for (p = args, cnt = -non_expand_num; !nilp(p); p = cdr(p), ++cnt) {
		SExp v = car(p);
		if (cnt >= 0 && (interval <= 1 || cnt % interval != 0)) {
			SExp e = macroexpand_1(v, v);
			if (!eq(e, v)) {
				chg = TRUE;
				v = e;
			}
		}
		push_stack(v);
		cons_on_stack();
	}
	if (chg) {
		return pop_nrev_stack();
	} else {
		pop_stack(1);
		return args;
	}
}

static SExp f_quote(SExp args, int macroexpand) {
	if (!macroexpand) {
		return car(args);
	} else {
		return args;
	}
}

// (set sym1 {val1} sym2 {val2} ...)
static SExp f_set(SExp args, int macroexpand) {
	if (!macroexpand) {
		SExp p = args;
		SExp r = nil;
		while (!nilp(p)) {
			SExp q, v;
			q = car(p);	p = cdr(p);
			if (nilp(p)) {
				error("odd argnum for set");
				break;
			}
			v = car(p);	p = cdr(p);
			q = type_check(q, tSymbol);
			r = run(v);
			push_stack(r);
			setq(q, r);
			set_name(r, q);
			pop_stack(1);
		}
		return r;
	} else {
		return macroexpand_sub(args, 1, 2);
	}
}

// (if c1 t1 c2 t2 ... e)
static SExp f_if(SExp args, int macroexpand) {
	if (!macroexpand) {
		for (; !nilp(args);) {
			SExp c = car(args);
			SExp ec = run(c);
			SExp d = cdr(args);
			if (nilp(d)) {
				return ec;
			} else if (!nilp(ec)) {
				SExp th = car(d);
				return run(th);
			}
			args = cdr(d);
		}
		return nil;
	} else {
		return macroexpand_sub(args, 1, 1);
	}
}

// (fn args body ...)
static SExp f_fn(SExp args, int macroexpand) {
	if (!macroexpand) {
		SExp arglist = car(args);
		SExp body = cdr(args);
		return gen_lambda(arglist, body, get_current_env());
	} else {
		return macroexpand_sub(args, 2, 1);
	}
}

// (macro args body ...)
static SExp f_macro(SExp args, int macroexpand) {
	if (!macroexpand) {
		SExp arglist = car(args);
		SExp body = cdr(args);
		return gen_macro(arglist, body, get_current_env());
	} else {
		return macroexpand_sub(args, 2, 1);
	}
}


/*
(define (transform-quasiquote args)
  (define (f x)
    (if (pair? x)
        (case (car x)
          ((unquote) (list 'list (cadr x)))
          ((unquote-splicing) (cadr x))
          (else (list 'list (transform-quasiquote x))))
      (list 'list (transform-quasiquote x))))
  (if (pair? args)
      (case (car args)
        ((unquote) (cadr args))
        ((unquote-splicing) (error "can't use: ',@x"))
        (else (cons 'append (map f args))))
    (list 'quote args)))
*/

static SExp transform_quasiquote(SExp args);
static SExp transform_quasiquote_elem(SExp x, void* _) {
	if (consp(x)) {
		SExp a = car(x);
		if (eq(a, intern("unquote"))) {
			return list3(intern("cons"), cadr(x), nil);
		} else if (eq(a, intern("unquote-splicing"))) {
			return cadr(x);
		}
	}
	return list3(intern("cons"), transform_quasiquote(x), nil);
}

static SExp transform_quasiquote(SExp args) {
	if (consp(args)) {
		SExp a = car(args);
		if (eq(a, intern("unquote"))) {
			return cadr(args);
		} else if (eq(a, intern("unquote-splicing"))) {
			return error("can't use: ~a", args);
		} else {
			push_stack(mapcar1(transform_quasiquote_elem, args, NULL));
			push_stack(intern("append"));
			cons_on_stack();
			return pop_stack(1);
		}
	} else {
		return list2(intern("quote"), args);
	}
}

static SExp f_quasiquote(SExp args, int macroexpand) {
	if (!macroexpand) {
		SExp s = car(args);
		SExp t = transform_quasiquote(s);
		return run(t);
	} else {
		SExp t = transform_quasiquote(cadr(args));
		return t;
	}
}



//=============================================================================
// subr

static SExp f_cons(int narg, SExp args[]) {
	return cons(args[0], args[1]);
}

static SExp f_car(int narg, SExp args[]) {
	return car(args[0]);
}

static SExp f_cdr(int narg, SExp args[]) {
	return cdr(args[0]);
}

static SExp f_consp(int narg, SExp args[]) {
	return consp(args[0]) ? t : nil;
}

static SExp f_scar(int narg, SExp args[]) {
	rplaca(args[0], args[1]);
	return args[1];
}

static SExp f_scdr(int narg, SExp args[]) {
	rplacd(args[0], args[1]);
	return args[1];
}


static SExp f_is(int narg, SExp args[]) {
	SExp x = args[0];
	int i;
	for (i=1; i<narg; ++i) {
		SExp y = args[i];
		if (!eq(x, y)) {
			SType tx = type_of(x), ty = type_of(y);
			if (tx == ty) {
				switch (tx) {
				default:	break;
				case tString:	if (string_compare(x, y) == 0)	continue;
				}
			}
			return nil;
		}
	}
	return t;
}

static SExp f_type(int narg, SExp args[]) {
	SExp s = args[0];
	const STypeInfo* p = get_type_info(s);
	return intern(p->class_name);
}

#include <stdlib.h>
#include "sstring.h"
#include "sfpnum.h"
// @fixme all

static SExp string2number(SExp s, SExp target) {
	const char* str = s.ptr->string.str;
	SExp r = make_number(str);
	if (nilp(r)) {
		r = error(ERR_CANT_COERCE, s, target);
	}
	return r;
}
static SExp fixnum2string(SExp s)	{ char buf[16]; sprintf(buf, "%d", s2fixnum(s)); return gen_str(buf, -1); }
static SExp fpnum2string(SExp s)	{ char buf[32]; sprintf(buf, "%g", s.ptr->fpnum.val); return gen_str(buf, -1); }
static SExp char2string(SExp s)		{ char buf[8]; sprintf(buf, "%c", s2char(s)); return gen_str(buf, -1); }
static SExp char2ascii(SExp s)		{ return fixnum2s(s2char(s)); }
static SExp ascii2char(SExp s)		{ return char2s(s2fixnum(s)); }

static SExp string2list(SExp s) {
	String* p = &s.ptr->string;
	const char* str = p->str;
	int n = p->len;
	int i;
	push_stack(nil);
	for (i=n; --i>=0; ) {
		push_stack(char2s(str[i]));
		cons_on_stack();
	}
	return pop_stack(1);
}

static SExp list2string(SExp s) {
	int l = list_length(s);
	char* buf = malloc(l+1);
	if (buf == NULL) {
		return error("out of memory");
	} else {
		SExp r;
		SExp p;
		char* q;
		for (p = s, q = buf; consp(p); p = cdr(p)) {
			SExp c = type_check(car(p), tChar);
			*q++ = s2char(c);
		}
		*q = '\0';
		r = gen_str(buf, -1);
		free(buf);
		return r;
	}
}

static SExp f_coerce(int narg, SExp args[]) {
	SExp s = args[0];
	SExp d = type_check(args[1], tSymbol);
	if (eq(d, intern("string"))) {
		// 3rd arg: base num
		switch (type_of(s)) {
		case tString:	return s;
		case tFixnum:	return fixnum2string(s);
		case tChar:		return char2string(s);
		case tSymbol:	return nilp(s) ? gen_str("", -1) : gen_str(s.ptr->symbol.str, -1);
		case tFPnum:	return fpnum2string(s);
		case tCell:		return list2string(s);
		}
	} else if (eq(d, intern("int"))) {
		// 3rd arg: base num
		switch (type_of(s)) {
		case tFixnum:	return s;
		case tChar:		return char2ascii(s);
		case tString:	return string2number(s, d);
		case tFPnum:	return fixnum2s((SFixnum)s.ptr->fpnum.val);
		}
	} else if (eq(d, intern("num"))) {
		// 3rd arg: base num
		switch (type_of(s)) {
		case tFixnum:	return gen_fpnum(s2fixnum(s));
		case tString:	return string2number(s, d);
		case tFPnum:	return s;
		}
	} else if (eq(d, intern("sym"))) {
		switch (type_of(s)) {
		case tSymbol:	return s;
		case tString:	return intern(s.ptr->string.str);
		}
	} else if (eq(d, intern("cons"))) {
		switch (type_of(s)) {
		case tCell:		return s;
		case tString:	return string2list(s);
		}
	} else if (eq(d, intern("char"))) {
		switch (type_of(s)) {
		case tChar:		return s;
		case tFixnum:	return ascii2char(s);
		}
	}
	return error(ERR_CANT_COERCE, s, d);
}

static SExp f_global_variable_ref(int narg, SExp args[]) {
	SExp s = args[0];
	return global_variable_ref(s);
}

static SExp f_plus(int narg, SExp args[]) {
	SFixnum r = 0;
	int i;
	for (i=0; i<narg; ++i) {
		SExp a = type_check(args[i], tFixnum);
		r += s2fixnum(a);
	}
	return fixnum2s(r);
}

static SExp f_times(int narg, SExp args[]) {
	SFixnum r = 1;
	int i;
	for (i=0; i<narg; ++i) {
		SExp a = type_check(args[i], tFixnum);
		r *= s2fixnum(a);
	}
	return fixnum2s(r);
}

static SExp f_difference(int narg, SExp args[]) {
	SExp a = type_check(args[0], tFixnum);
	SFixnum r = s2fixnum(a);
	if (narg == 1) {
		r = -r;
	} else {
		int i;
		for (i=1; i<narg; ++i) {
			SExp a = type_check(args[i], tFixnum);
			r -= s2fixnum(a);
		}
	}
	return fixnum2s(r);
}

static SExp f_quotient(int narg, SExp args[]) {
	SExp a = type_check(args[0], tFixnum);
	SFixnum r = s2fixnum(a);
	if (narg == 1) {
		r = 1 / r;
	} else {
		int i;
		for (i=1; i<narg; ++i) {
			SExp a = type_check(args[i], tFixnum);
			r /= s2fixnum(a);
		}
	}
	return fixnum2s(r);
}

static SExp f_mod(int narg, SExp args[]) {
	SExp a = type_check(args[0], tFixnum);
	SFixnum aa = s2fixnum(a);
	SExp b = type_check(args[1], tFixnum);
	SFixnum bb = s2fixnum(b);

/*
	 mod    | C  | Arc |
	--------+----+-----+
	 1 %  2 |  1 |  1  |
	-1 %  2 | -1 |  1  |
	 1 % -2 |  1 | -1  |
	-1 % -2 | -1 | -1  |
*/
	SFixnum ar = ABS(aa) % ABS(bb);
	SFixnum sr = ar * SGN(bb);
	return fixnum2s(sr);
}

static SExp cmp_num(int narg, SExp args[], int (*cmp)(SExp, SExp)) {
	SExp a = type_check(args[0], tFixnum);
	int i;
	for (i=1; i<narg; ++i) {
		SExp b = type_check(args[i], tFixnum);
		if (!(cmp(a, b))) {
			return nil;
		}
		a = b;
	}
	return t;
}

static int cmp_eq(SExp a, SExp b) { return s2fixnum(a) == s2fixnum(b); }
static SExp f_numeq(int narg, SExp args[]) {
	return cmp_num(narg, args, cmp_eq);
}

static int cmp_lt(SExp a, SExp b) { return s2fixnum(a) < s2fixnum(b); }
static SExp f_lt(int narg, SExp args[]) {
	return cmp_num(narg, args, cmp_lt);
}

static int cmp_gt(SExp a, SExp b) { return s2fixnum(a) > s2fixnum(b); }
static SExp f_gt(int narg, SExp args[]) {
	return cmp_num(narg, args, cmp_gt);
}

static int cmp_le(SExp a, SExp b) { return s2fixnum(a) <= s2fixnum(b); }
static SExp f_le(int narg, SExp args[]) {
	return cmp_num(narg, args, cmp_le);
}

static int cmp_ge(SExp a, SExp b) { return s2fixnum(a) >= s2fixnum(b); }
static SExp f_ge(int narg, SExp args[]) {
	return cmp_num(narg, args, cmp_ge);
}

static SExp f_apply(int narg, SExp args[]) {
	SExp fn = args[0];
	if (narg <= 2) {
		return apply(fn, args[1], FALSE);
	} else {
		SExp s, r;
		int i = narg;
		push_stack(args[--i]);
		for (; --i > 0; ) {
			push_stack(args[i]);
			cons_on_stack();
		}
		s = ref_stack(1);
		r = apply(fn, s, FALSE);
		pop_stack(1);
		return r;
	}
}

static SExp f_append(int narg, SExp args[]) {
	if (narg <= 1) {
		return narg == 0 ? nil : args[0];
	} else {
		SExp r = nil;
		int i;
		for (i=narg; --i >= 0; ) {
			push_stack(r);
			if (!nilp(r)) {
				r = nconc2(copy_list(args[i]), r);
			} else {
				r = args[i];
			}
			pop_stack(1);
		}
		return r;
	}
}



static SExp f_read(int narg, SExp args[]) {
	SExp strm = sstdin;
	if (narg >= 1) {
		strm = args[0];
	}
	return read(strm);
}

static SExp f_eval(int narg, SExp args[]) {
	SExp r;
	SExp s = args[0];
	push_stack(get_current_env()); {
		set_env(make_empty_env());
		r = eval(s);
	} set_env(pop_stack(1));
	return r;
}

static SExp f_disp(int narg, SExp args[]) {
	SExp s = args[0];
	SExp strm = sstdout;
	if (narg >= 2) {
		strm = args[1];
	}
	write(s, strm, FALSE);
	return nil;
}



static SExp f_load(int narg, SExp args[]) {
	SExp fname = type_check(args[0], tString);
	String* p = (String*)fname.ptr;
	const char* cstr = p->str;
	SExp r = load_exec(cstr);
	if (!nilp(r)) {
		return t;
	} else {
		error(ERR_CANT_LOAD, fname);
		return nil;
	}
}

static SExp f_quit(int narg, SExp args[]) {
	int res = 0;
	if (narg >= 1) {
		SExp r = args[0];
		if (fixnump(r)) {
			res = s2fixnum(r);
		} else {
			res = -1;
		}
	}
	exit(res);
}

static SExp f_uniq(int narg, SExp args[]) {
	return gensym();
}

static SExp f_macroexpand_1(int narg, SExp args[]) {
	SExp s = args[0];
	SExp r;
	push_stack(get_current_env()); {
		set_env(make_empty_env());
		r = macroexpand_1(s, s);
	} set_env(pop_stack(1));
	return r;
}

static SExp f_macex(int narg, SExp args[]) {
	SExp s = args[0];
	SExp r;
	push_stack(get_current_env()); {
		set_env(make_empty_env());
		r = macroexpand(s, s);
	} set_env(pop_stack(1));
	return r;
}



extern BAlloc s_balloc;
static SExp f_meminfo(int narg, SExp args[]) {
	int total_free_size, max_block_size;
	int nalloc = balloc_get_info(&s_balloc, &total_free_size, &max_block_size);

	push_stack(nil);;
	push_stack(cons(intern("max-block-size"), fixnum2s(max_block_size)));
	cons_on_stack();
	push_stack(cons(intern("total-free"), fixnum2s(total_free_size)));
	cons_on_stack();
	push_stack(cons(intern("allocated-num"), fixnum2s(nalloc)));
	cons_on_stack();
	return pop_stack(1);
}

#include "smem.h"
static SExp f_memdump(int narg, SExp args[]) {
	smem_dump(sstdout);
	return nil;
}

#include "hashtable.h"
extern HashTable s_symbol_table;
static SExp f_symtblinfo(int narg, SExp args[]) {
	int size, elem, collide, maxcollide;
	ht_get_info(&s_symbol_table, &size, &elem, &collide, &maxcollide);
	printf("entry:%d/%d, collide:%d, max %d\n", elem, size, collide, maxcollide);
	return nil;
}

#include "smem.h"
static SExp f_collect_garbage(int narg, SExp args[]) {
	mlisp_gc();
	return nil;
}

extern SExp call_list;
static SExp f_backtrace(int narg, SExp args[]) {
	// car of call_list is this function, so omit that
	return cdr(call_list);
}


// for test
static SExp f_fnbody(int narg, SExp args[]) {
	SExp s = args[0];
	switch (type_of(s)) {
	default:
		return nil;
	case tLambda:
		return s.ptr->lambda.body;
	case tMacro:
		return s.ptr->macro.body;
	}
}
static SExp f_fnarg(int narg, SExp args[]) {
	SExp s = args[0];
	switch (type_of(s)) {
	default:
		return nil;
	case tLambda:
		return s.ptr->lambda.arglist;
	case tMacro:
		return s.ptr->macro.arglist;
	}
}


//=============================================================================
// Reader macro

#if 0
static SExp close_paren_reader(int narg, SExp args[]) {
	SExp strm = args[0];
	SExp ch = args[1];
	sungetch(s2chr(ch), strm);
	return sERR;
}

static SExp quote_reader(int narg, SExp args[]) {
	SExp strm = args[0];
	SExp s = read(strm, sreader_macro);
	return list2(intern("quote"), s);
}

static SExp backquote_reader(int narg, SExp args[]) {
	SExp strm = args[0];
	SExp s = read(strm, sreader_macro);
	return list2(intern("quasiquote"), s);
}
#endif


static void set_macro_chr(SExp chr, SExp f) {
	set_macro_character(chr, f);
}

static SExp read_delimited_list(int ch, SExp strm) {
	push_stack(nil);
	for (;;) {
		int c = sgetch(strm);
		if (c == ch) {
			return pop_nrev_stack();
		} else {
			SExp s;
			sungetch(c, strm);
			s = read(strm);
			push_stack(s);
			cons_on_stack();
		}
	}
}

static void define_reader_macro() {
#if 0
	struct {
		char chr;
		const char* name;
		SubrType cfunc;
	} static const tbl[] = {
		{	')',	"|)-reader|",	close_paren_reader,	},
		{	'`',	"|`-reader|",	backquote_reader,	},
		{	'\'',	"|'-reader|",	quote_reader,	},
	};
	int i;
	sreader_macro = gen_reader_macro();
	for (i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
		SExp sf = gen_subr(tbl[i].cfunc, tbl[i].name, 2, 2);
		setq(intern(tbl[i].name), sf);
		set_macro_chr(chr2s(tbl[i].chr), sf);
	}
#endif
}


static SExp f_set_macro_character(int narg, SExp args[]) {
	SExp chr = args[0];
	SExp f = args[1];
	//SExp non_terminating_p = args[2];
	//SExp read_table = args[3];
	set_macro_chr(chr, f);
	return t;
}

static SExp f_get_macro_character(int narg, SExp args[]) {
	SExp chr = args[0];
	//SExp read_table = args[1];
	return get_macro_character(chr);
}

static SExp f_read_delimited_list(int narg, SExp args[]) {
	SExp c = args[0];
	SExp strm = (narg >= 2) ? args[1] : sstdin;
	return read_delimited_list(s2char(c), strm);
}


static SExp f_make_dispatch_macro_character(int narg, SExp args[]) {
	SExp chr = args[0];
	if (make_dispatch_macro_character(chr)) {
		return t;
	} else {
		return nil;
	}
}

static SExp f_set_dispatch_macro_character(int narg, SExp args[]) {
	SExp chr1 = args[0];
	SExp chr2 = args[1];
	SExp f = args[2];
	if (set_dispatch_macro_character(chr1, chr2, f)) {
		return t;
	} else {
		return error("not dispatch chr: ~a", chr1);
	}
}

static SExp f_get_dispatch_macro_character(int narg, SExp args[]) {
	SExp chr1 = args[0];
	SExp chr2 = args[1];
	return get_dispatch_macro_character(chr1, chr2);
}



//=============================================================================

void define_specialform(void) {
	struct {
		const char* name;
		SpecialFormType cfunc;
		int minargnum, maxargnum;
	} static const tbl[] = {
		{	"quote",		f_quote,		1,	1,	},
		{	"set",			f_set,			2,	-1,	},
		{	"if",			f_if,			0,	-1,	},
		{	"fn",			f_fn,			1,	-1,	},
		{	"macro",		f_macro,		1,	-1,	},

		{	"quasiquote",	f_quasiquote,	1,	1,	},
	};
	int i;
	for (i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
		SExp mac = gen_specialform(tbl[i].cfunc, tbl[i].name, tbl[i].minargnum, tbl[i].maxargnum);
		SExp sym = intern(tbl[i].name);
		setq(sym, mac);
	}
}

void define_subr(void) {
	struct {
		const char* name;
		SubrType cfunc;
		int minargnum, maxargnum;
	} static const tbl[] = {
		{	"cons",					f_cons,					2,	2,	},
		{	"car",					f_car,					1,	1,	},
		{	"cdr",					f_cdr,					1,	1,	},
		{	"consp",				f_consp,				1,	1,	},
		{	"scar",					f_scar,					2,	2,	},
		{	"scdr",					f_scdr,					2,	2,	},
		{	"is",					f_is,					2,	-1,	},
		{	"+",					f_plus,					0,	-1,	},
		{	"*",					f_times,				0,	-1,	},
		{	"-",					f_difference,			1,	-1,	},
		{	"/",					f_quotient,				1,	-1,	},
		{	"mod",					f_mod,					2,	2,	},
		{	"==",					f_numeq,				2,	-1,	},
		{	"<",					f_lt,					2,	-1,	},
		{	">",					f_gt,					2,	-1,	},
		{	"<=",					f_le,					2,	-1,	},
		{	">=",					f_ge,					2,	-1,	},
		{	"apply",				f_apply,				2,	-1,	},
		{	"append",				f_append,				0,	-1,	},
		{	"type",					f_type,					1,	1,	},
		{	"coerce",				f_coerce,				2,	3,	},

		{	"read",					f_read,					0,	1,	},
		{	"eval",					f_eval,					1,	1,	},
		{	"disp",					f_disp,					1,	2,	},

		{	"load",					f_load,					1,	1,	},
		{	"quit",					f_quit,					0,	1,	},
		{	"uniq",					f_uniq,					0,	0,	},
		{	"macroexpand-1",		f_macroexpand_1,		1,	1,	},
		{	"macex",				f_macex,				1,	1,	},
		{	"global-variable-ref",	f_global_variable_ref,	1,	1,	},

		{	"set-macro-character",	f_set_macro_character,	2,	2,	},
		{	"get-macro-character",	f_get_macro_character,	1,	1,	},
		{	"read-delimited-list",	f_read_delimited_list,	1,	2,	},
		{	"make-dispatch-macro-character",	f_make_dispatch_macro_character,	1,	1,	},
		{	"set-dispatch-macro-character",		f_set_dispatch_macro_character,	3,	3,	},
		{	"get-dispatch-macro-character",		f_get_dispatch_macro_character,	2,	2,	},

		{	"meminfo",				f_meminfo,				0,	0,	},
		{	"memdump",				f_memdump,				0,	0,	},
		{	"symtblinfo",			f_symtblinfo,			0,	0,	},
		{	"collect-garbage",		f_collect_garbage,		0,	0,	},
		{	"backtrace",			f_backtrace,			0,	0,	},

		{	"fnbody",				f_fnbody,				1,	1,	},
		{	"fnarg",				f_fnarg,				1,	1,	},
	};
	int i;
	for (i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
		SExp subr = gen_subr(tbl[i].cfunc, tbl[i].name, tbl[i].minargnum, tbl[i].maxargnum);
		SExp sym = intern(tbl[i].name);
		setq(sym, subr);
	}
}

void define_const(void) {
	defconst(intern("nil"), nil);
	defconst(intern("t"), t);

	{
		struct {
			const char* name;
			int val;
		} static const tbl[] = {
			{	"most-positive-fixnum",		FIXNUM_MAX,	},
			{	"most-negative-fixnum",		FIXNUM_MIN,	},
		};
		int i;
		for (i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
			SExp val = fixnum2s(tbl[i].val);
			SExp sym = intern(tbl[i].name);
			defconst(sym, val);
		}
	}
}


static void mark_mlisp(void) {
	SMARK(sstdin);
	SMARK(sstdout);
	SMARK(sstderr);
	SMARK(call_list);
}


void init_mlisp(void) {
	define_specialform();
	define_subr();
	define_const();
	define_reader_macro();

	sstdin = make_file_stream(stdin, "<stdin>");
	setq(intern("*standard-input*"), sstdin);

	sstdout = make_file_stream(stdout, "<stdout>");
	setq(intern("*standard-output*"), sstdout);

	sstderr = make_file_stream(stderr, "<errout>");
	setq(intern("*error-output*"), sstderr);
}

void term_mlisp(void) {
}

void mlisp_gc(void) {
	static int starvation;
	assert(starvation == 0);
	++starvation;

	mark_env();
	mark_symbol_table();
	mark_reader();
	mark_mlisp();
	mark_stack();
	ssweep();

	--starvation;
}


SExp load_exec(const char* fn) {
	SExp r = nil;
	FILE* fp = fopen(fn, "r");
	if (fp != NULL) {
		SExp strm = make_file_stream(fp, fn);
		push_stack(strm);
		for (;;) {
			SExp s;
			s = read(strm);
			if (eq(s, sEOF))	break;
			r = eval(s);
		}
		pop_stack(1);
		fclose(fp);
	}
	return r;
}

SExp exec_string(const char* str) {
	SExp strm = make_str_stream(str);
	SExp r = nil;
	for (;;) {
		SExp s;
		s = read(strm);
		if (eq(s, sEOF))	break;
		r = eval(s);
	}
	return r;
}

SExp call_func(SExp fn, int narg, ...) {
	va_list ap;
	SExp args, r;
	int i;

	va_start(ap, narg);
	push_stack(nil);
	for (i=0; i<narg; ++i) {
		SExp s = va_arg(ap, SExp);
		push_stack(s);
		cons_on_stack();
	}
	va_end(ap);

	args = nreverse(ref_stack(1));
	r = apply(fn, args, FALSE);
	pop_stack(1);
	return r;
}
